perm filename LOSS.1[MAC,LSP]4 blob sn#557821 filedate 1981-01-15 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 SAIL LET add let! earlier
C00008 ENDMK
CāŠ—;
;;; SAIL LET add let! earlier
;;; Does lambda binding
(declare (*fexpr code)(*expr %match macrobind %%destructurify%% %%expand%% 
			     sail-letp)
	 (special %%clobber-macros%%))
(declare 
 (special *bindings *form *vars *vals *a *b *vars1 *vars2 *vals1 *vals2 ?t-w))

(defprop %match ((dsk (mac lsp)) match fas) autoload)
(defprop code ((dsk (mac lsp)) macrod fas) autoload)

(defun do-execute-memq (x)
       (memq x '(do execute)))  

(defun then-meanwhile-memq (x)
       (memq x '(then meanwhile)))  

		
(defun (let macro) (x)
       (cond ((not (memq '/← (cdr x)))
	      `(let! . ,(cdr x)))
	     (t
	      ((lambda (q)
		       (cond ((and
			       *rset 
			       (cond ((boundp '%%clobber-macros%%)
				      (not %%clobber-macros%%))
				     (t))) 
			      q)
			     ((atom q)
			      q)
			     (t (rplaca x (car q))
				(rplacd x (cdr q)))))   
	       ((lambda (*bindings *form ?t-w)
			(cond ((%match '(*bindings ($r ?t-w then-meanwhile-memq)
						   *form) (cdr x))
			       (cond ((eq ?t-w 'then)
				      (setq *form (ncons (cons 'let *form))))
				     (t
				      (setq *form (list (car *form)
							(cons 'let (cdr *form)))))))
			      (t (%match '(*bindings 
					   ($r ? do-execute-memq)
					   *form) (cdr x))))
			((lambda (*vars *vals)
				 (do ((*a nil *a)
				      (*b nil *b))
				     ((null (%match '(*a ← *b)
						    *bindings))
				      ((lambda (*vars1 *vals1 *vars2 *vals2)
					       (mapc 
						(function 
						 (lambda 
						  (q)
						  (and (car q)
						       (setq *vars1 (cons (car q) *vars1)
							     *vals1 (cons (cadr q) *vals1)))
						  (mapc
						   (function
						    (lambda (r)
							    (setq *vars2 (cons (car r) *vars2)
								  *vals2 (cons (cadr r) *vals2))))
						   (caddr q))))
						(%%destructurify%% *vars *vals))
					       (setq *vars1 (nreverse *vars1)
						     *vars2 (nreverse *vars2)
						     *vals1 (nreverse *vals1)
						     *vals2 (nreverse *vals2))
					       (cond ((null *vars1)
						      (cond ((null *vars2)
							     (code (progn *form)))
							    (t 
							     (code
							      ((lambda (*vars2)
								       *form)
							       *vals2)))))
						     (t 
						      (cond ((null *vars2)
							     (code 
							      ((lambda (*vars1)
								       *form)
							       *vals1)))
							    (t 
							     (code ((lambda (*vars1) 
									    ((lambda (*vars2)
										     *form)
									     *vals2))
								    *vals1)))))))
				       nil nil nil nil))
				     (do ((n (1- (length *a))
					     (1- n))
					  (x (ncons (car *b))
					     (cons (car *b) x)))
					 ((zerop n) (setq *bindings (cdr *b)
							  *b (nreverse x)))
					 (setq *b (cdr *b)))
				     (setq *vars (append
						  *vars *a)
					   *vals (append
						  *vals *b)))) 
			 nil nil)) nil nil nil))) ))

;(defun destructure (l)
;       (destructure1 l nil))

(defun %%destructure1%% (l path)
       (cond ((null l) nil)
	     ((atom l)(ncons (cons l path)))
	     (t (append (%%destructure1%% (car l) (cons 'car path))
			(%%destructure1%% (cdr l) (cons 'cdr path))))))  

(defun %%destructurify%% (vars vals)
 (mapcar
  (function
   (lambda (q r)
	   (cond ((atom q)
		   (list q r nil))
		 ((atom r)
		  (list nil nil (%%pathify%% (%%destructure1%% q nil) r)))
		 (t ((lambda (g)
		      (list g r (%%pathify%% (%%destructure1%% q nil) g)))  
		     (gensym))))))
  vars vals))

(defun %%pathify%% (path gen)
       (mapcar
	(function 
	 (lambda (q)
	  (list (car q) (%%code-path%% (cdr q) gen))))  
	 path))

(defun %%code-path%% (path name)
 (cond ((null path) name)
       (t (list (car path) (%%code-path%% (cdr path) name)))))